home *** CD-ROM | disk | FTP | other *** search
/ Meeting Pearls 2 / Meeting Pearls Vol. II (1995)(GTI - Schatztruhe)[!].iso / Pearls / dev / TurboM2 / m2 / FIO.mod < prev    next >
Text File  |  1994-12-27  |  22KB  |  797 lines
  1. IMPLEMENTATION MODULE FIO ;
  2.  
  3. FROM SYSTEM IMPORT ADDRESS, ADR ;
  4. IMPORT StdIO, Storage ;
  5.  
  6. MODULE CISupport ;
  7.  
  8.   IMPORT StdIO, ADDRESS, ADR ;
  9.  
  10.   EXPORT
  11.     fseek, ftell, fopen, fclose, fread, fwrite, setvbuf,
  12.     getc, ungetc, putc, fwriteinteger, freadreal,fflush,
  13.     fwritereal, freadlongreal,fwritelongreal, freadstr,
  14.     formatreal, formatlongreal ;
  15.  
  16.   CONST
  17.     tableSize = StdIO.FOPEN_MAX ;
  18.  
  19.   VAR
  20.     stdFiles : ARRAY [0..tableSize-1] OF StdIO.FILEPtr ;
  21.  
  22.   PROCEDURE fopen( VAR name, mode : ARRAY OF CHAR ) : LONGINT ;
  23.  
  24.     PROCEDURE firstnull( ) : LONGINT ;
  25.       VAR i : LONGINT ;
  26.     BEGIN
  27.       i := 3 ;
  28.       WHILE i < tableSize DO
  29.         IF stdFiles[i] = NIL THEN RETURN i END ;
  30.         INC( i )
  31.       END ;
  32.       HALT
  33.     END firstnull ;
  34.  
  35.   VAR
  36.     f : StdIO.FILEPtr ;
  37.     i : LONGINT ;
  38.  
  39.   BEGIN
  40.     f := StdIO.fopen( name, mode );
  41.     IF f # NIL THEN i := firstnull( ) ; stdFiles[i] := f ELSE i := -1 END ;
  42.     RETURN i
  43.   END fopen ;
  44.  
  45.   PROCEDURE setvbuf(  file  : LONGINT ;
  46.                  buf  : ADDRESS ;
  47.                  mode : LONGINT ;
  48.                  size : LONGINT ) : BOOLEAN ;
  49.   BEGIN RETURN StdIO.setvbuf( stdFiles[file], buf, mode, size ) = 0
  50.   END setvbuf ;
  51.  
  52.   PROCEDURE fclose( file : LONGINT ) ;
  53.   BEGIN StdIO.fclose( stdFiles[file] ) ; stdFiles[file] := NIL
  54.   END fclose ;
  55.  
  56.   PROCEDURE fflush( file : LONGINT ) ;
  57.   BEGIN StdIO.fflush( stdFiles[file] )
  58.   END fflush ;
  59.  
  60.   PROCEDURE fseek( file, offset, pos : LONGINT ) : BOOLEAN ;
  61.   BEGIN RETURN StdIO.fseek( stdFiles[file], pos, offset ) = 0
  62.   END fseek ;
  63.  
  64.   PROCEDURE ftell( file : LONGINT ) : LONGINT ;
  65.   BEGIN RETURN StdIO.ftell( stdFiles[file] )
  66.   END ftell ;
  67.  
  68.   PROCEDURE fread( file , n : LONGINT ; buf : ADDRESS ) : LONGINT ;
  69.   BEGIN RETURN StdIO.fread( buf, 1, n, stdFiles[file] )
  70.   END fread ;
  71.  
  72.   PROCEDURE fwrite( file , n : LONGINT ; buf : ADDRESS ) : LONGINT ;
  73.   BEGIN RETURN StdIO.fwrite( buf, 1, n, stdFiles[file] )
  74.   END fwrite ;
  75.  
  76.   PROCEDURE getc( file : LONGINT ) : LONGINT ;
  77.   BEGIN RETURN StdIO.fgetc( stdFiles[file] )
  78.   END getc ;
  79.  
  80.   PROCEDURE ungetc( file : LONGINT ; c : LONGINT ) ;
  81.   BEGIN StdIO.ungetc( c, stdFiles[file] )
  82.   END ungetc ;
  83.  
  84.   PROCEDURE putc( file : LONGINT ; c : LONGINT ) : BOOLEAN ;
  85.   BEGIN RETURN StdIO.fputc( c, stdFiles[file] ) # StdIO.EOF
  86.   END putc ;
  87.  
  88.   PROCEDURE freadinteger( file : LONGINT ; VAR i : LONGINT ) : BOOLEAN ;
  89.   BEGIN RETURN StdIO.fscanf( stdFiles[file], "%d", i ) = 1
  90.   END freadinteger ;
  91.  
  92.   PROCEDURE fwriteinteger( file : LONGINT ; i : LONGINT ) : BOOLEAN ;
  93.   BEGIN RETURN StdIO.fprintf( stdFiles[file], "%d", i ) # 0
  94.   END fwriteinteger ;
  95.  
  96.   PROCEDURE freadreal( file : LONGINT ; VAR r : REAL ) : BOOLEAN ;
  97.   BEGIN RETURN StdIO.fscanf( stdFiles[file], "%f", ADR( r ) ) = 1
  98.   END freadreal ;
  99.  
  100.   PROCEDURE freadlongreal( file : LONGINT ; VAR r : LONGREAL ) : BOOLEAN ;
  101.   BEGIN RETURN StdIO.fscanf( stdFiles[file], "%lf", ADR( r ) ) = 1
  102.   END freadlongreal ;
  103.  
  104.   PROCEDURE fwritereal( file : LONGINT ; r : REAL ) : BOOLEAN ;
  105.   BEGIN RETURN StdIO.fprintf( stdFiles[file], "%g", r ) # 0
  106.   END fwritereal ;
  107.  
  108.   PROCEDURE fwritelongreal( file : LONGINT ; r : LONGREAL ) : BOOLEAN ;
  109.   BEGIN RETURN StdIO.fprintf( stdFiles[file], "%g", r ) # 0
  110.   END fwritelongreal ;
  111.  
  112.   PROCEDURE formatreal( file: LONGINT ; r: REAL ; w,d : LONGINT ) : BOOLEAN ;
  113.     VAR format : ARRAY [0..29] OF CHAR ;
  114.   BEGIN
  115.     StdIO.sprintf( format, "%%%d.%df", w, d ) ;
  116.     RETURN StdIO.fprintf( stdFiles[file], format, r ) # 0
  117.   END formatreal ;
  118.  
  119.   PROCEDURE formatlongreal( file : LONGINT ;
  120.                        r : LONGREAL ;
  121.                     w, d : LONGINT ) : BOOLEAN ;
  122.     VAR format : ARRAY [0..29] OF CHAR ;
  123.   BEGIN
  124.     StdIO.sprintf( format, "%%%d.%dlf", w, d );
  125.     RETURN StdIO.fprintf( stdFiles[file], format, r ) # 0
  126.   END formatlongreal ;
  127.  
  128.   PROCEDURE freadstr( file : LONGINT ;
  129.                VAR s : ARRAY OF CHAR ;
  130.                    m : LONGINT ) : BOOLEAN ;
  131.     VAR i , c : LONGINT ; ch : CHAR ;
  132.   BEGIN
  133.     FOR i := 0 TO m DO s[i] := 0C END ;
  134.     i := 0 ;
  135.     LOOP
  136.       c := StdIO.fgetc( stdFiles[file] ) ;
  137.       IF c = StdIO.EOF THEN RETURN FALSE END ;
  138.       ch := CHR( c ) ;
  139.       IF (ch = ' ') OR ( ch = '\t') OR (ch = '\n') THEN EXIT END ;
  140.       s[i] := ch ;
  141.       INC( i ) ;
  142.       IF i>m THEN RETURN TRUE END
  143.     END ;
  144.     StdIO.ungetc( c, stdFiles[file] ) ;
  145.     RETURN TRUE
  146.   END freadstr ;
  147.  
  148. BEGIN stdFiles := [StdIO.stdin, StdIO.stdout, StdIO.stderr]
  149. END CISupport ;
  150.  
  151. CONST
  152.   Tab      = "\t" ;
  153.   NewLine  = "\n" ;
  154.   Space    = " "  ;
  155.  
  156.   HitEOF   =  -1 ;
  157.  
  158. TYPE
  159.   (* File is the index into files array *)
  160.  
  161.   FileType = ( none, reading, writing, random ) ;
  162.   FileSet  = SET OF FileType ;
  163.  
  164.   FCB      = RECORD
  165.     type     : FileType ;
  166.     ioresult : Status   ;
  167.     name     : POINTER TO ARRAY [0..1024] OF CHAR ;  (* Alloced less *)
  168.     nameSize : LONGINT  ; (* Number of bytes alloced to name *)
  169.     filedes  : LONGINT  ; (* file descriptor             *)
  170.     pad      : INTEGER  ; (* Makes record size a power of 2  *)
  171.   END ;
  172.  
  173.   FileArray = ARRAY [0..MaxFiles] OF FCB;
  174.  
  175. (* NOTE: element
  176.  *   0 is for open's which fail
  177.  *       1 is stdin
  178.  *       2 is stdout
  179.  *       3 is stderr
  180.  *)
  181.  
  182. VAR
  183.   files    : FileArray ;
  184.   modename : ARRAY FileType OF ARRAY [0..30] OF CHAR ;
  185.  
  186. (* -------------------- Private procedures section ------------------- *)
  187.  
  188. PROCEDURE len( s : (*@N*) ARRAY OF CHAR ) : LONGINT ;
  189.   VAR i : LONGINT ;
  190. BEGIN
  191.   FOR i := 0 TO HIGH( s ) DO
  192.     IF s[i] = 0C THEN RETURN i END
  193.   END ;
  194.   RETURN 1+HIGH(s)
  195. END len ;
  196.  
  197. PROCEDURE errstr( s : (*@N*) ARRAY OF CHAR ) ;
  198. BEGIN StdIO.fprintf( StdIO.stderr, "%s", s )
  199. END errstr ;
  200.  
  201. PROCEDURE errline;
  202. BEGIN StdIO.fprintf( StdIO.stderr, "\n" )
  203. END errline ;
  204.  
  205. PROCEDURE findfree() : File;
  206. (* finds the first free position in the file array *)
  207.   VAR i : File ;
  208. BEGIN
  209.   FOR i := StdErr+1 TO MaxFiles DO
  210.     IF files[i].type = none THEN RETURN i END
  211.   END;
  212.   RETURN 0
  213. END findfree ;
  214.  
  215. PROCEDURE openfile( fname , fmode : (*@N*) ARRAY OF CHAR ;
  216.                 ftype   : FileType ;
  217.             badstat : Status ) : File ;
  218.  
  219. (* open a file: called by all three OpenTo procedures *)
  220.  
  221.   VAR
  222.     filepos : File ;
  223.     i       : LONGINT ;
  224.     c       : LONGINT ;
  225.  
  226. BEGIN
  227.   filepos := findfree( ) ;
  228.  
  229.   i := len( fname ) ;
  230.   files[filepos].nameSize := i+1 ; (* Allocate one extra char for 0C *)
  231.   Storage.ALLOCATE( files[filepos].name , i+1 ) ;
  232.   FOR c := 0 TO i-1 DO files[filepos].name^[c] := fname[c] END ;
  233.   files[filepos].name^[i] := 0C ;
  234.  
  235.   IF filepos = 0 THEN
  236.     files[filepos].ioresult := TooManyOpen
  237.   ELSE
  238.     i := fopen( files[filepos].name^ , fmode ) ;
  239.     IF i = -1 THEN
  240.       files[filepos].ioresult := badstat ;
  241.       files[0] := files[filepos] ;
  242.       filepos := 0
  243.     ELSE
  244.       files[filepos].type := ftype ;
  245.       files[filepos].filedes := i ;
  246.       files[filepos].ioresult := NoError
  247.     END
  248.   END ;
  249.   RETURN filepos
  250. END openfile ;
  251.  
  252. PROCEDURE checkopenfor( procname : (*@N*) ARRAY OF CHAR ;
  253.                     file  : File ;
  254.                     modes : FileSet ) ;
  255.   VAR openmode : FileType ;
  256. BEGIN
  257.   (* check that the file is open, first *)
  258.   IF ( file < 0 ) OR ( file > MaxFiles ) OR ( files[file].type = none ) THEN
  259.     errstr( "FIO." ) ;
  260.     errstr( procname ) ;
  261.     errstr(" : File has not been opened !!") ;
  262.     errline( ) ;
  263.     HALT ;
  264.   END ;
  265.   openmode := files[file].type ;
  266.   IF NOT ( openmode IN modes ) THEN
  267.     errstr( "FIO." ) ;
  268.     errstr( procname ) ;
  269.     errstr(" : file '") ;
  270.     errstr( files[file].name^ ) ;
  271.     errstr("' ") ;
  272.     errstr("was opened for ") ;
  273.     errstr( modename[openmode] ) ;
  274.     errline( ) ;
  275.     HALT ;
  276.   END
  277. END checkopenfor ;
  278.  
  279. PROCEDURE prematureEOF( procname : (*@N*) ARRAY OF CHAR ; file : File ) ;
  280. BEGIN
  281.   errstr( "FIO." ) ;
  282.   errstr( procname ) ;
  283.   errstr(" : premature EOF occurred in file '") ;
  284.   errstr( files[file].name^ ) ;
  285.   errstr("' ") ;
  286.   errline( ) ;
  287.   HALT ;
  288. END prematureEOF ;
  289.  
  290. (*----------------------------------------------------------------------------*)
  291.  
  292. PROCEDURE IOStatus( file : File ) : Status;
  293. BEGIN
  294.   IF ( file < 0 ) OR ( file > MaxFiles ) THEN file := 0 END ;
  295.   RETURN files[file].ioresult
  296. END IOStatus ;
  297.  
  298. PROCEDURE ReportError( file : File ) ;
  299. BEGIN
  300.   IF ( file < 0 ) OR ( file > MaxFiles ) THEN file := 0 END ;
  301.   CASE files[file].ioresult OF
  302.   |  NoError:
  303.      RETURN        (* only way of returning *)
  304.   | UnInitialized :
  305.     errstr("FIO: File being used when not open - unitialized")
  306.   | CantOpenFile :
  307.     errstr("FIO: File '") ;
  308.     errstr( files[file].name^ ) ;
  309.     errstr("' does not exist, or cannot be opened")
  310.   | CantCreateFile :
  311.     errstr("FIO: File '") ;
  312.     errstr( files[file].name^ ) ;
  313.     errstr("' cannot be created")
  314.   | TooManyOpen :
  315.     errstr("FIO: Can't open file '") ;
  316.     errstr( files[file].name^ ) ;
  317.     errstr("' too many files open already")
  318.   | OpFailed :
  319.     errstr("FIO: Operation on file '") ;
  320.     errstr( files[file].name^ ) ;
  321.     errstr("' failed")
  322.   END ;
  323.   errline( ) ;
  324.   HALT ;
  325. END ReportError ;
  326.  
  327. PROCEDURE OpenToRead( fname : (*@N*) ARRAY OF CHAR ) : File ;
  328. BEGIN RETURN openfile( fname, "r ", reading, CantOpenFile )
  329. END OpenToRead ;
  330.  
  331. PROCEDURE OpenToWrite( fname : (*@N*) ARRAY OF CHAR ) : File ;
  332. BEGIN RETURN openfile( fname, "w ", writing, CantCreateFile )
  333. END OpenToWrite ;
  334.  
  335. PROCEDURE OpenForRandom( fname :(*@N*) ARRAY OF CHAR ; create: BOOLEAN ): File ;
  336. BEGIN
  337.   IF create THEN RETURN openfile( fname, "w+", random, CantCreateFile )
  338.   ELSE RETURN openfile( fname, "r+", random, CantOpenFile )
  339.   END
  340. END OpenForRandom ;
  341.  
  342.  
  343. PROCEDURE SetBuffer( file : File ;
  344.              mode : BufferingMode ;
  345.              size : LONGINT ;
  346.              buff : ADDRESS ) ;
  347.   VAR
  348.     stdMode : LONGINT ;
  349. BEGIN
  350.   checkopenfor("SetBuffer", file, FileSet{reading,writing,random} ) ;
  351.   CASE mode OF
  352.   | NoBuffer   : stdMode := StdIO._IONBF
  353.   | LineBuffer : stdMode := StdIO._IOLBF
  354.   | FullBuffer : stdMode := StdIO._IOFBF
  355.   END ;
  356.   IF setvbuf( files[file].filedes, buff, stdMode, size ) THEN
  357.     files[file].ioresult := NoError
  358.   ELSE files[file].ioresult := OpFailed
  359.   END
  360. END SetBuffer ;
  361.  
  362. PROCEDURE Close( file : File ) ;
  363. BEGIN
  364.   (* check that the file is open, first *)
  365.   IF ( file<0 ) OR ( file>MaxFiles ) OR ( files[file].type = none ) THEN
  366.     ReportError( file )
  367.   END ;
  368.   (* now close it *)
  369.   fclose( files[file].filedes ) ;
  370.   files[file].type     := none ;
  371.   files[file].ioresult := UnInitialized ;
  372.   IF file > 2 THEN
  373.     Storage.DEALLOCATE( files[file].name , files[file].nameSize )
  374.   END
  375. END Close ;
  376.  
  377. PROCEDURE FlushFile( f : File ) ;
  378. BEGIN
  379.   checkopenfor("FlushFile", f, FileSet{reading,writing,random} ) ;
  380.   fflush( files[f].filedes )
  381. END FlushFile ;
  382.  
  383. PROCEDURE EOF( file : File ) : BOOLEAN ;
  384.   VAR
  385.     i : LONGINT ;
  386.     f : LONGINT ;
  387. BEGIN
  388.   checkopenfor("EOF", file, FileSet{reading,random} ) ;
  389.   f := files[file].filedes ;
  390.   i := getc( f ) ;
  391.   ungetc( f, i ) ;
  392.   files[file].ioresult := NoError ;
  393.   RETURN i = HitEOF
  394. END EOF ;
  395.  
  396. PROCEDURE EOLN( file : File ) : BOOLEAN ;
  397.   VAR
  398.     i : LONGINT ;
  399.     f : LONGINT ;
  400. BEGIN
  401.   checkopenfor("EOLN", file, FileSet{reading,random} ) ;
  402.   f := files[file].filedes ;
  403.   i := getc( f ) ;
  404.   ungetc( f, i ) ;
  405.   files[file].ioresult := NoError ;
  406.   RETURN i = ORD( NewLineCh ) ;
  407. END EOLN ;
  408.  
  409. PROCEDURE SetPosition( file : File; pos : LONGINT ; end : EndType ) ;
  410.   VAR
  411.     val : LONGINT ;
  412. BEGIN
  413.   IF ( pos = 0 ) & ( end = FromStart ) THEN
  414.     checkopenfor("SetPosition", file, FileSet{reading,random} )
  415.   ELSE checkopenfor("SetPosition", file, FileSet{random} )
  416.   END ;
  417.   CASE end OF
  418.   |  FromStart   : val := 0
  419.   |  FromCurrent : val := 1
  420.   |  AddToEnd    : val := 2
  421.   END ;
  422.   IF fseek( files[file].filedes, pos, val ) THEN
  423.     files[file].ioresult := NoError
  424.   ELSE files[file].ioresult := OpFailed
  425.   END
  426. END SetPosition ;
  427.  
  428. PROCEDURE FindPosition( file : File ) : LONGINT ;
  429. BEGIN
  430.   checkopenfor("FindPosition", file, FileSet{random} ) ;
  431.   files[file].ioresult := NoError ;
  432.   RETURN ftell( files[file].filedes )
  433. END FindPosition ;
  434.  
  435. PROCEDURE Rewind( file : File ) ;
  436. BEGIN
  437.   (* INLINE CALL: SetPosition( file, 0, FromStart ); *)
  438.   IF fseek( files[file].filedes, 0, 0 ) THEN
  439.     files[file].ioresult := NoError
  440.   ELSE files[file].ioresult := OpFailed
  441.   END
  442. END Rewind ;
  443.  
  444. PROCEDURE ReadNBytes( file : File ; n : LONGINT ; buffer : ADDRESS ) ;
  445.   VAR k : LONGINT ;
  446. BEGIN
  447.   checkopenfor("ReadNBytes", file, FileSet{reading,random} ) ;
  448.   k := fread( files[file].filedes, n, buffer ) ;
  449.   IF k = n THEN files[file].ioresult := NoError
  450.   ELSIF ( k > 0 ) OR (n = 0) THEN
  451.     files[file].ioresult := OpFailed
  452.   ELSE prematureEOF("ReadNBytes", file )
  453.   END
  454. END ReadNBytes ;
  455.  
  456. PROCEDURE WriteNBytes( file : File ; n : LONGINT ; buffer : ADDRESS ) ;
  457. BEGIN
  458.   checkopenfor("WriteNBytes", file, FileSet{writing,random} ) ;
  459.   IF fwrite( files[file].filedes, n, buffer ) = n THEN
  460.     files[file].ioresult := NoError
  461.   ELSE files[file].ioresult := OpFailed
  462.   END
  463. END WriteNBytes ;
  464.  
  465. PROCEDURE SkipBlanks( f : File ) ;
  466. (* Skip blanks: tabs and spaces. Not newlines *)
  467.   VAR
  468.     ch : CHAR ;
  469.     i  : LONGINT ;
  470. BEGIN
  471.   checkopenfor("SkipBlanks", f, FileSet{reading,random} );
  472.   LOOP
  473.     i := getc( files[f].filedes );
  474.     IF i = HitEOF THEN EXIT; END;
  475.     ch := CHR(i);
  476.     IF ( ch # Space ) & ( ch # Tab ) THEN
  477.       ungetc( files[f].filedes, i ) ;
  478.       EXIT
  479.     END
  480.   END
  481. END SkipBlanks ;
  482.  
  483. PROCEDURE SkipWS( f : File ) ;
  484. (* Skip all whitespace (spaces, tabs and newlines) *)
  485.   VAR
  486.     ch : CHAR ;
  487.     i  : LONGINT ;
  488. BEGIN
  489.   checkopenfor("SkipWS", f, FileSet{reading,random} ) ;
  490.   LOOP
  491.     i := getc( files[f].filedes ) ;
  492.     IF i = HitEOF THEN EXIT END ;
  493.     ch := CHR(i) ;
  494.     IF ( ch # Space ) & ( ch # Tab ) & ( ch # NewLine ) THEN
  495.       ungetc( files[f].filedes, i ) ; EXIT
  496.     END
  497.   END
  498. END SkipWS ;
  499.  
  500. PROCEDURE EOFAfterWS( f : File ) : BOOLEAN ;
  501. (* After skipping whitespace; are we now at EOF? *)
  502.   VAR
  503.     ch : CHAR ;
  504.     i  : LONGINT ;
  505. BEGIN
  506.   (* INLINE CALLS: SkipWS( f ); RETURN EOF( f ); *)
  507.   checkopenfor("EOFAfterWS", f, FileSet{reading,random} );
  508.   LOOP
  509.     i := getc( files[f].filedes );
  510.     IF i = HitEOF THEN RETURN TRUE; END;
  511.     ch := CHR(i);
  512.     IF ( ch # Space ) & ( ch # Tab ) & ( ch # NewLine ) THEN
  513.       ungetc( files[f].filedes, i ) ; RETURN FALSE
  514.     END
  515.   END
  516. END EOFAfterWS ;
  517.  
  518. PROCEDURE skipws( procname : (*@N*) ARRAY OF CHAR; f : File ) ;
  519. (* internal utility procedure: check open for reading/random, *)
  520. (* skips whitespace, and goes bang if it hits premature EOF.. *)
  521.   VAR
  522.     i  : LONGINT ;
  523.     ch : CHAR ;
  524. BEGIN
  525.   checkopenfor( procname, f, FileSet{reading,random} ) ;
  526.   REPEAT
  527.     i := getc( files[f].filedes ) ;
  528.     IF i = HitEOF THEN prematureEOF( procname, f ) END ;
  529.     ch := CHR(i)
  530.   UNTIL (ch # ' ') & (ch # TabCh) & (ch # NewLineCh) ;
  531.   ungetc( files[f].filedes, i )
  532. END skipws ;
  533.  
  534. PROCEDURE ReadInteger( file : File ) : LONGINT ;
  535.  
  536.   CONST
  537.     minint = MIN(LONGINT) ;
  538.     maxint = MAX(LONGINT) ;
  539.  
  540.     minintdiv = minint DIV 10 ;       (* eg. -3781 => -378 *)
  541.     minintmod = ABS(minint MOD 10) ;  (* eg. -3781 =>    1 *)
  542.  
  543.     maxintdiv = maxint DIV 10 ;
  544.     maxintmod = maxint MOD 10 ;
  545.  
  546.   VAR
  547.     negative : BOOLEAN ;
  548.     ch       : CHAR    ;
  549.     i        : LONGINT ;
  550.     digit    : LONGINT ;
  551.     result   : LONGINT ;
  552.     first    : BOOLEAN ;
  553.  
  554. BEGIN
  555.   skipws("ReadInteger", file ) ;
  556.   i := getc( files[file].filedes ) ;
  557.   ch := CHR(i) ;
  558.   negative := ch = '-' ;
  559.   IF (ch # '+') & (ch # '-') THEN ungetc( files[file].filedes, i ) END ;
  560.  
  561.   (* Accumulate the integer in result, check for overflow at each digit *)
  562.  
  563.   first := TRUE ;
  564.   result := 0 ;
  565.   LOOP
  566.     i := getc( files[file].filedes ) ;
  567.     digit := i - ORD('0') ;
  568.     IF (digit < 0) OR (digit > 9) THEN EXIT END ;
  569.     first := FALSE ;
  570.     IF negative THEN
  571.       IF (result<minintdiv )OR((result = minintdiv ) & (digit > minintmod)) THEN
  572.         files[file].ioresult := Overflow ;
  573.         RETURN 0
  574.       END ;
  575.       result := result*10 - digit
  576.     ELSE
  577.       IF (result>maxintdiv) OR ((result = maxintdiv) & (digit > maxintmod)) THEN
  578.         files[file].ioresult := Overflow ;
  579.         RETURN 0
  580.       END ;
  581.       result := result*10 + digit
  582.     END
  583.   END ;
  584.   ungetc( files[file].filedes, i ) ;
  585.   IF first THEN files[file].ioresult := OpFailed
  586.   ELSE files[file].ioresult := NoError
  587.   END ;
  588.   RETURN result
  589. END ReadInteger ;
  590.  
  591. PROCEDURE WriteInteger( file : File ; object : LONGINT ) ;
  592. BEGIN
  593.   checkopenfor("WriteInteger", file, FileSet{random,writing} ) ;
  594.   IF fwriteinteger( files[file].filedes, object ) THEN
  595.     files[file].ioresult := NoError
  596.   ELSE files[file].ioresult := OpFailed
  597.   END
  598. END WriteInteger ;
  599.  
  600. PROCEDURE ReadReal( file : File ) : REAL ;
  601.   VAR k : REAL ;
  602. BEGIN
  603.   skipws("ReadReal", file ) ;
  604.   IF freadreal( files[file].filedes, k ) THEN
  605.     files[file].ioresult := NoError
  606.   ELSE files[file].ioresult := OpFailed
  607.   END ;
  608.   RETURN k
  609. END ReadReal ;
  610.  
  611. PROCEDURE WriteReal( file : File ; object : REAL ) ;
  612. BEGIN
  613.   checkopenfor("WriteReal", file, FileSet{random,writing} ) ;
  614.   IF fwritereal( files[file].filedes, object ) THEN
  615.     files[file].ioresult := NoError
  616.   ELSE files[file].ioresult := OpFailed
  617.   END
  618. END WriteReal ;
  619.  
  620. PROCEDURE WriteRealFmt( file : File ; r : REAL ; width, decplaces : LONGINT ) ;
  621. BEGIN
  622.   checkopenfor("WriteRealFmt", file, FileSet{random,writing} ) ;
  623.   IF formatreal( files[file].filedes, r, width, decplaces ) THEN
  624.     files[file].ioresult := NoError
  625.   ELSE files[file].ioresult := OpFailed
  626.   END
  627. END WriteRealFmt ;
  628.  
  629. PROCEDURE ReadLongReal( file : File ) : LONGREAL ;
  630.   VAR k : LONGREAL ;
  631. BEGIN
  632.   skipws("ReadLongReal", file ) ;
  633.   IF freadlongreal( files[file].filedes, k ) THEN
  634.     files[file].ioresult := NoError
  635.   ELSE files[file].ioresult := OpFailed
  636.   END ;
  637.   RETURN k
  638. END ReadLongReal ;
  639.  
  640. PROCEDURE WriteLongReal( file : File ; object : LONGREAL ) ;
  641. BEGIN
  642.   checkopenfor("WriteLongReal", file, FileSet{random,writing} ) ;
  643.   IF fwritelongreal( files[file].filedes, object ) THEN
  644.     files[file].ioresult := NoError
  645.   ELSE files[file].ioresult := OpFailed
  646.   END
  647. END WriteLongReal ;
  648.  
  649. PROCEDURE WriteLongRealFmt( file : File ;
  650.                    r : LONGREAL ;
  651.                 width, decplaces : LONGINT ) ;
  652. BEGIN
  653.   checkopenfor("WriteLongRealFmt", file, FileSet{random,writing} );
  654.   IF formatlongreal( files[file].filedes, r, width, decplaces ) THEN
  655.     files[file].ioresult := NoError
  656.   ELSE files[file].ioresult := OpFailed
  657.   END
  658. END WriteLongRealFmt ;
  659.  
  660. PROCEDURE ReadChar( file : File ) : CHAR ;
  661.   VAR i : LONGINT ;
  662. BEGIN
  663.   checkopenfor("ReadChar", file, FileSet{reading,random} ) ;
  664.   i := getc( files[file].filedes ) ;
  665.   IF i = HitEOF THEN prematureEOF("ReadChar", file ) END ;
  666.   files[file].ioresult := NoError ;
  667.   RETURN CHR(i)
  668. END ReadChar ;
  669.  
  670. PROCEDURE WriteChar( file : File; object : CHAR ) ;
  671. BEGIN
  672.   checkopenfor("WriteChar", file, FileSet{random,writing} );
  673.   IF putc( files[file].filedes, ORD(object) ) THEN
  674.     files[file].ioresult := NoError
  675.   ELSE files[file].ioresult := OpFailed
  676.   END
  677. END WriteChar ;
  678.  
  679. PROCEDURE ReadString( file : File ; VAR s : ARRAY OF CHAR ) ;
  680. BEGIN
  681.   skipws("ReadString", file ) ;
  682.   IF freadstr( files[file].filedes, s, HIGH(s) ) THEN
  683.     files[file].ioresult := NoError
  684.   ELSE prematureEOF("ReadString", file )
  685.   END
  686. END ReadString ;
  687.  
  688. PROCEDURE WriteString( file : File ; object : (*@N*) ARRAY OF CHAR ) ;
  689.   VAR l : LONGINT ;
  690. BEGIN
  691.   checkopenfor("WriteString", file, FileSet{random,writing} ) ;
  692.   l := len( object ) ;
  693.   IF fwrite( files[file].filedes, l, ADR(object) ) = l THEN
  694.     files[file].ioresult := NoError
  695.   ELSE files[file].ioresult := OpFailed
  696.   END
  697. END WriteString ;
  698.  
  699. PROCEDURE ReadLine( file : File ) ;
  700.   VAR i : LONGINT ;
  701. BEGIN
  702.   checkopenfor("ReadLine", file, FileSet{reading,random} ) ;
  703.   REPEAT
  704.     i := getc(files[file].filedes) ;
  705.     IF i = HitEOF THEN prematureEOF("ReadLine", file ) END
  706.   UNTIL CHR(i) = NewLineCh ;
  707.   files[file].ioresult := NoError
  708. END ReadLine ;
  709.  
  710. PROCEDURE WriteLine( file : File ) ;
  711. BEGIN WriteChar( file, NewLineCh )
  712. END WriteLine ;
  713.  
  714. PROCEDURE UnReadChar( file : File ; c : CHAR ) ;
  715. (* currently no check to avoid two successive unreadchar calls *)
  716. (* probably worth having one....                   *)
  717. BEGIN
  718.   checkopenfor("UnReadChar", file, FileSet{reading,random} ) ;
  719.   ungetc( files[file].filedes, ORD(c) ) ;
  720.   files[file].ioresult := NoError
  721. END UnReadChar ;
  722.  
  723. PROCEDURE ReadLn( f : File ; VAR s : ARRAY OF CHAR ) ;
  724.   VAR
  725.     pos   : LONGINT ;
  726.     ch    : CHAR ;
  727.     error : BOOLEAN ;
  728. BEGIN
  729.   error := FALSE ;
  730.   pos   := 0 ;
  731.   WHILE NOT EOLN( f ) DO
  732.     ch := ReadChar( f ) ;
  733.     IF pos <= HIGH(s) THEN s[pos] := ch ELSE error := TRUE END ;
  734.     INC( pos )
  735.   END ;
  736.   ReadLine( f ) ;
  737.   IF pos <= HIGH(s) THEN s[pos] := 0C END ;
  738.   IF error THEN
  739.     WriteString( StdErr, "FIO.ReadLn: warning - line too long, truncated") ;
  740.     WriteLine( StdErr )
  741.   END
  742. END ReadLn ;
  743.  
  744. PROCEDURE WriteLn( f : File ; s : (*@N*) ARRAY OF CHAR ) ;
  745. BEGIN WriteString( f, s ) ; WriteLine( f )
  746. END WriteLn ;
  747.  
  748. (*----------------------------------------------------------------------------*)
  749.  
  750. PROCEDURE Delete( name : (* @N *) ARRAY OF CHAR ) : BOOLEAN ;
  751. (* Returns TRUE on success, FALSE otherwise *)
  752. BEGIN RETURN StdIO.remove( name ) = 0
  753. END Delete ;
  754.  
  755. PROCEDURE Rename( old , new : (* @N *) ARRAY OF CHAR ) : BOOLEAN ;
  756. (* Returns TRUE on success, FALSE otherwise *)
  757. BEGIN RETURN StdIO.rename( old , new ) = 0
  758. END Rename ;
  759.  
  760. (* -------------------------- initialization code -------------------------- *)
  761.  
  762. VAR
  763.   i : LONGINT ;
  764.  
  765. BEGIN
  766.   modename[none]    := "none...ahem.." ;
  767.   modename[reading] := "reading" ;
  768.   modename[writing] := "writing" ;
  769.   modename[random]  := "random" ;
  770.  
  771.   FOR i := 0 TO MaxFiles DO
  772.     files[i].type     := none ;
  773.     files[i].filedes  := -1 ;
  774.     files[i].ioresult := UnInitialized ;
  775.     files[i].name     := ADR("no name") ;
  776.   END ;
  777.  
  778.   StdIn  := 1 ;
  779.   StdOut := 2 ;
  780.   StdErr := 3 ;
  781.  
  782.   files[StdIn].type      := reading  ;
  783.   files[StdIn].filedes   := 0        ;
  784.   files[StdIn].ioresult  := NoError  ;
  785.   files[StdIn].name      := ADR("stdin")  ;
  786.  
  787.   files[StdOut].type     := writing  ;
  788.   files[StdOut].filedes  := 1        ;
  789.   files[StdOut].ioresult := NoError  ;
  790.   files[StdOut].name     := ADR("stdout") ;
  791.  
  792.   files[StdErr].type     := writing  ;
  793.   files[StdErr].filedes  := 2        ;
  794.   files[StdErr].ioresult := NoError  ;
  795.   files[StdErr].name     := ADR("stderr") ;
  796. END FIO.
  797.